home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / WAFPEGTP / PEGWAF.PAS < prev    next >
Pascal/Delphi Source File  |  1994-12-31  |  46KB  |  1,479 lines
  1. {$A+,B-,D-,E-,F-,I+,L-,N-,O-,R-,S+,V-}
  2. {$M 16000,0,10000}
  3. program pegwaf;
  4.  
  5. {
  6.  
  7. pascal hack of filter.c
  8. from the udg.zip distributed with PMail 2.3(r2)
  9. Main benefit is that it can deliver mail to a remote server
  10. so you only need one gateway for an internet of novell servers
  11. Who needs mhs ?
  12.  
  13.     Copyright (C) 1992  Dr Ross Lazarus
  14.  
  15.     This program is free software; you can redistribute it and/or modify
  16.     it under the terms of the GNU General Public License as published by
  17.     the Free Software Foundation; either version 1, or (at your option)
  18.     any later version.
  19.  
  20.     This program is distributed in the hope that it will be useful,
  21.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  22.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23.     GNU General Public License for more details.
  24.  
  25.     You should have received a copy of the GNU General Public License
  26.     along with this program; if not, write to the Free Software
  27.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  28.  
  29.     Dr Ross Lazarus is the original copyright holder of this code.
  30.     Email: rossl@gmu.wh.su.edu.au
  31.     Mail: Department of Community Medicine,
  32.           Westmead Hospital
  33.           Westmead, NSW 2145
  34.           Australia
  35.     Fax: (+61 2) 689 1049
  36.  
  37.  
  38. see original comments reproduced below
  39. rossl@gmu.wh.su.oz.au
  40. Started june 10 1992
  41.  
  42. + added compiler directives to remove remote server access for a public
  43.   release of the source without that unit January 1994 rml
  44.  
  45. + added code to locate first non local drive - use instead of default F:
  46.   also changed from m: to p: as remote drive
  47.   and changed pmgate.sys to use z: as the netware drive. This makes it
  48.   possible to use machines which have lastdrive=j in them for multiplatter
  49.   or other perversions. May 22 1993 rml
  50.  
  51. + altered received by lines in response to suggestions april 1993
  52.  
  53. + added standalone operation feb 93
  54.  
  55. + writec bug found and fixed when string too long...
  56.  
  57. + added code to fix the ccmail zap in the .xqt file ! rml 14 sept 1992
  58.  
  59. + added window code for announcements so PMail screen is restored to
  60.   original condition. Fixed default remote login as guest, no pass
  61.   3/9/92 rml
  62.  
  63. + added code to zap crap added by cc:mail when forwarding - @aaEXTERNAL
  64.   gets added to the address causing the mail to be bounced angrily. This
  65.   is now fixed automatically.
  66.  
  67. + added code to write all outgoing mail to an outbox specified in static
  68.   file as pw.outbox in waffle type format. Updates index file and
  69.   creates new file if necessary rml 25/8/92. Problem. The pegwaf remote
  70.   login as well as everyone on the gateway server need rcws rights, so
  71.   anyone can read this file !!!! Not ideal but at least it seems to
  72.   work. Might be more elegant for this to happen before a poll or when
  73.   there's incoming mail ?
  74.  
  75. + added code to check that this is a receipt confirmation - no fussing
  76.   with screen even if beta as it causes confusion ! 21/8/92 rml
  77.  
  78. + added code to generate 4 digit unique waffle outgoing spool file names
  79.   to overcome the danger inherent in not checking that the file already
  80.   exists in the spool directory first. Also, waffle does not like
  81.   non numeric file names - uuq does not work if letter in filename.
  82.   17/august 1992 rml
  83.  
  84. + changed udg parameters to avoid problems with long return addresses
  85.   exceeding the dos command line limit of ?127 characters. Now gets
  86.   date and user from dos and netware respectively. Set the udg screen
  87.   of pconfig to use
  88.   uucpmail ~c ~t [remote server] [remote userid] [remote password]
  89.   10/august 1992 rml
  90.  
  91. + added detach_from_fileserer call to detach properly after leaving
  92.   remote server. Also added realname in brackets after from: field
  93.  
  94. + if organ set in waffle static file, an organization: line added to
  95.   headers of mail going out.
  96.  
  97. + PMail putting blanks in reply-to: which is confusing some mailers -
  98.   blank reply-to: now crunched - passed through if has an address
  99.  
  100. + if fails for any reason, tries to bounce the message. Assumes netmail
  101.   lives in f:\mail
  102.  
  103. + if 8th parameter, then gateway is assumed to be on a remote server
  104.   with p8 = servername, p9 = remotehostloginid, p10 = remotehostpassword.
  105.   because of limitations in parameter passing, the default of path of
  106.   \waffle\system\static is assumed for the waffle static file
  107.  
  108.   Otherwise the waffle static file must be available as the WAFFLE
  109.   environment variable and the waffle server is assumed to be the
  110.   currently logged one.
  111.  
  112.   default waffle static file f:\waffle\system\static assumed
  113.   if no env variable set 23/7/92 rml
  114.  
  115. + xqt and dat files must have NEWLINE ONLY - not crlf pairs 8/9/92 rml
  116.  
  117.  
  118. }
  119. (*
  120. from
  121.  * filter.c
  122.  * a program to take the output produced by Pegasus Mail/PC in standalone
  123.  * mode, and place it appropriately. with associated
  124.  * support .cmd and .xqt files for mail processing using the Waffle BBS uucico
  125.  * and uuxqt programs.
  126.  *
  127.  * Pegasus Mail/PC (C) Copyright 1990, 1991, David Harris, Dunedin, New Zealand
  128.  * WAFFLE  (C) Copyright 1991 by Darkside International of Mountain View CA.
  129.  *
  130.  * Author: Brendan Murray, Dunedin, New Zealand
  131.  * Permission is granted to do whatever you like with this code. Just about
  132.  * anyone ought to be able to improve on it. No warranty whatsoever is granted
  133.  * or implied.
  134.  *
  135.  
  136.  *    Actions
  137.  *    1. Take the RFC 822 message produced by PMail and prepend a
  138.  *        uucp acceptible From line
  139.  *    2. Create a .cmd file to tell UUCICO what to do
  140.  *    3. Create a .xqt file to tell UUXQT what to do at the other end
  141.  *)
  142.  
  143. {$define single}
  144. (*
  145. To compile this public code release, single MUST be defined. Otherwise
  146. you need remote novell server login/map code which will be provided for
  147. an appropriate fee to those wanting it
  148. *)
  149. {$ifdef single}
  150. uses dos,crt,novell,awindow;
  151. {$else}
  152. uses dos,crt,novell,novell2,awindow;
  153. {$endif}
  154.  
  155.  
  156. const
  157.      firstdrive : string[2] = 'F:';
  158.      copyright = 'Copyright Dr Ross Lazarus, 1992. This is FREE COPYRIGHT software.';
  159.      copyright2 = 'If you were charged anything for this software, please contact the author.';
  160.      pmenvar = 'PMUSER'; { standalone dos environment variable -> user name }
  161.      standalone : boolean = false;
  162.      containerparam = 1;
  163.      toparam = 2;
  164.      rservparam = 3;
  165.      ruserparam = 4;
  166.      hostlogin : string[50] = 'GUEST';
  167.      rpassparam = 5;
  168.      hostpass : string[40] = '';
  169.      toline = 'TO:';
  170.      ccmailstuff = '@aaEXTERNAL';
  171.      replyto = 'REPLY-TO:';
  172.      subject = 'SUBJECT:';
  173.      confirmation : boolean = false;
  174.      confirm = 'SUBJECT:RECEIPTCONFIRMATION';
  175.      from = 'FROM:';
  176.      userobject = 1;
  177.      remotedrive = 'P:';
  178.      PMailext = '.CNM'; { new file extension for bounce if fails }
  179.      netmaildir : string = '\mail';
  180.      defaultwafdir : string = '\WAFFLE\SYSTEM\STATIC';
  181.      newline = chr($0a);
  182.      nullc = chr($01);
  183.      mailsep : string[4] = nullc + nullc + nullc + nullc;
  184.      hn = 'UUCPNAME'; { constants to look for in waffle static file }
  185.      sm = 'SMARTHOST';
  186.      sp = 'SPOOL';
  187.      tz = 'TIMEZONE';
  188.      org = 'ORGAN';
  189.      nn = 'NODE';
  190.      ob = 'PW.OUTBOX';
  191.      outboxindexext = 'i';
  192.      outboxext = 'f';
  193.      waffleset = 'WAFFLE'; { dos env var name of waffle static file path }
  194.      datext = '.DAT'; { file name extensions for uucico }
  195.      xqtext = '.XQT';
  196.      prog = 'PegWaf';
  197.      progname = 'PegWaf. Waffle 1.65 UDG for the Pegasus EMailer';
  198.      version = 'v0.34s 94.12.31';
  199.      ver = version + ', Enquiries: rossl@gmu.wh.su.edu.au';
  200.      ccmailzap : boolean = false;
  201.      killsent = true;
  202.      { set to true to delete PMail temporary files on completion }
  203.  
  204. type
  205.     hexidtype = array[1..4] of byte;
  206.     _datestring = string[10];
  207.     timetype = record
  208.                      h,m,s,s100 : word;
  209.                end;
  210.     windex = record { a waffle mailbox index file record }
  211.                    offset : longint;
  212.                    length : longint;
  213.                    stuff : array[1..28] of byte;
  214.              end;
  215.  
  216. var
  217.    remotegateway : boolean;
  218.    station,defaultserverid,remotehandle,remoteserverid : integer;
  219.    regs : registers;
  220.    f : file;
  221.    outfile,infile : text;
  222.    dat_FileName,cmd_FileName,xqt_FileName,
  223.    shorthostname,
  224.    HostName,    (* this host *)
  225.    SmartHost,   (* who sends things on for us *)
  226.    Spool,    (* where to put things *)
  227.    TimeZone,    (* for the header *)
  228.    Organization,(* more header *)
  229.    outbox,      (* pw outbox *)
  230.    nodename,    (* this hosts internet name *)
  231.    drive,dir,wafname,ext,wafdir,sender,null,uservername,
  232.    containername,realname,homedir : string[100];
  233.    tmpstring : string;
  234.    rc,i,cntr,cntr2,dummy : integer;
  235.    rights : byte;
  236.    ch : char;
  237.    datesent : string;
  238.    started,now : longint;
  239.    t : timetype;
  240.  
  241. function msec(t : timetype) : longint;
  242. {
  243. convert time to 100ths of sec since midnite
  244. }
  245. begin
  246.      with t do
  247.           msec := s100 + 100*s + 6000*m + 360000*h;
  248. end; { msec }
  249.  
  250. Procedure WriteC( St:string ; LineNO : integer);
  251. var
  252.    m,w,l : integer;
  253.    st2 : string;
  254.  
  255. begin
  256.      m := (lo(windmax) - lo(windmin));
  257.      w := m div 2; { half width }
  258.      l := length(st);
  259.      if (l >= m) then
  260.      begin
  261.           st := copy(st,1,m);
  262.           l := m;
  263.      end;
  264.      gotoxy(succ(w - (length(St) div 2)),Lineno);
  265.      write(st);
  266. end; { writec }
  267.  
  268. procedure wait;
  269.  
  270. var
  271.    c : char;
  272.  
  273. begin
  274.      writec('Press any key to continue',succ(wherey));
  275.      while keypressed do
  276.         c := readkey;
  277.      repeat
  278.      until keypressed;
  279.      c := readkey;
  280. end;
  281.  
  282.  
  283. procedure badnews(s : string);
  284. {
  285. announce s as bad news and exit
  286. }
  287. begin
  288.      window(5,10,75,15,fc,bc,drev,shad);
  289.      windowtitle(prog + ' ' + version + ' Fatal Error');
  290.      writec(s,2);
  291.      wait;
  292.      closewindow;
  293.      wait;
  294.      halt(1);
  295. end; { badnews }
  296.  
  297. function hexidtostring(x : hexidtype) : string;
  298. {
  299. translate a 4 byte address into a numeric string
  300. }
  301.  
  302. const
  303.      HEXDIGITS : Array [0..15] of char = '0123456789081726';
  304.  
  305. var
  306.    hex_id : string;
  307.    id : array[1..4] of byte absolute x;
  308.  
  309. begin
  310.    hex_id := '';
  311.    hex_id := hexdigits[Id[1] shr 4]; { lower nibble }
  312.    hex_id := hex_id + hexdigits[Id[1] and $0F]; { upper }
  313.    hex_id := hex_id + hexdigits[Id[2] shr 4];
  314.    hex_id := hex_id + hexdigits[Id[2] and $0F];
  315.    hex_id := hex_id + hexdigits[Id[3] shr 4];
  316.    hex_id := hex_id + hexdigits[Id[3] and $0F];
  317.    hex_id := hex_id + hexdigits[Id[4] shr 4];
  318.    hex_id := hex_id + hexdigits[Id[4] and $0F];
  319.    hexidtostring := hex_id;
  320. end;
  321.  
  322. function exists(fn : string) : boolean;
  323. {
  324. return true if fn is a file name
  325. }
  326. var
  327.    s : searchrec;
  328.  
  329. begin
  330.      findfirst(fn,anyfile,s);
  331.      exists := (doserror = 0) ;
  332. end;
  333.  
  334.  
  335. function UpcaseStr(S : String) : String;
  336. (* converts a string to upper case *)
  337.  
  338. var
  339.   P : Integer;
  340. begin
  341.   for P := 1 to Length(S) do
  342.     S[P] := Upcase(S[P]);
  343.   UpcaseStr := S;
  344. end; { Upcasestr }
  345.  
  346. function lowercaseStr(S : String) : String;
  347. (* converts a string to lower case *)
  348.  
  349. var
  350.   P : Integer;
  351.   c : char;
  352.  
  353. begin
  354.   for P := 1 to Length(S) do
  355.   begin
  356.        c := s[p];
  357.        if (c >= 'A') and (c <= 'Z') then
  358.           S[P] := chr(ord(c) + ord(' '));
  359.   end;
  360.   lowercaseStr := S;
  361. end; { lowercasestr }
  362.  
  363. function trim(trime : String) : String;
  364. { trim trailing blanks by adjusting the length byte at trime[0] }
  365.  
  366. const
  367.      blank = ' ';
  368.  
  369. var
  370.    l : integer;
  371.  
  372. begin
  373.      l := ord(trime[0]);
  374.      while (l > 0) and (trime[l] = blank) do
  375.            l := pred(l);
  376.      trime[0] := chr(l);
  377.      trim := trime;
  378. end; { trim }
  379.  
  380. function mirt(trime : String) : String;
  381. { trim all blanks }
  382.  
  383. const
  384.      blank = ' ';
  385.  
  386. var
  387.    p,l : integer;
  388.    s : string;
  389.  
  390. begin
  391.      p := 1;
  392.      s := '';
  393.      l := ord(trime[0]);
  394.      if l > 0 then
  395.      begin
  396.           while (p <= l) and (trime[p] = blank) do
  397.              p := succ(p); { point to first non blank }
  398.           s := copy(trime,p,999);
  399.      end;
  400.      mirt := s;
  401. end; { mirt }
  402.  
  403. function noblanks(trime : String) : String;
  404. { trim all blanks }
  405.  
  406. const
  407.      blank = ' ';
  408.  
  409. var
  410.    l : integer;
  411.    t : string;
  412.  
  413. begin
  414.      t := '';
  415.      for l := 1 to length(trime) do
  416.          if (trime[l] <> blank) then
  417.             t := t + trime[l];
  418.      noblanks := t;
  419. end; { noblanks }
  420.  
  421. function before(sep : string ; s : string) : string;
  422. {
  423. return characters up to sep in s
  424. if no sep, return whole of s
  425. }
  426. var
  427.    i : integer;
  428.  
  429. begin
  430.      i := pos(sep,s);
  431.      if (i = 0) then
  432.         before := s
  433.      else
  434.          before := copy(s,1,pred(i));
  435. end;
  436.  
  437. function after(sep :string ; var s : string) : string;
  438. {
  439. return characters after sep in s
  440. if no sep, returns null string
  441. }
  442.  
  443. var
  444.    i,j,l : integer;
  445.  
  446. begin
  447.      l := length(s);
  448.      j := length(sep);
  449.      i := pos(sep,s);
  450.      while (copy(s,i+j,j) = sep) and (i < l) do
  451.            inc(i,j);
  452.      if (i = 0) or (i >= l)  then
  453.         after := ''
  454.      else
  455.          after := copy(s,i + j,999);
  456. end; { after }
  457.  
  458.  
  459. {---------------- date and time support ------------------}
  460. const
  461.      daypos = 1;
  462.      monthpos = 3;
  463.      Limit      : Array[1..13] of Integer = (31,29,31,30,31,30,31,31,30,31,30,31,31);
  464.      MthTab     : Array[1..12] of String[9] = ('Jan','Feb','Mar',
  465.                                              'Apr','May','Jun','Jul',
  466.                                              'Aug','Sep','Oct',
  467.                                              'Nov','Dec');
  468.      DayTab     : Array[0..6] of String[9] = ('Sun','Mon','Tue',
  469.                                             'Wed','Thu','Fri',
  470.                                             'Sat');
  471.  
  472. Function SysTime : String;
  473. Var
  474.   H, M, S : String[2];
  475.   hh,mm,ss,s100 : word;
  476.  
  477. Begin
  478.      gettime(hh,mm,ss,s100);
  479.      Str(hh:2, H);
  480.      Str(mm:2, M);
  481.      Str(ss:2, S);
  482.      if H[1] = ' ' then H[1] := '0';
  483.      if M[1] = ' ' then M[1] := '0';
  484.      if S[1] = ' ' then S[1] := '0';
  485.      SysTime := H + ':' + M + ':' + S
  486. End;
  487.  
  488.  
  489. Function rfc822date : String;
  490.  
  491. Var
  492.   I     : Integer;
  493.   S1,S2,today : String[30];
  494.   dd,mm,yy,d,hh,ss,s100 : word;
  495.   ds : string[2];
  496.   ys : string[4];
  497.   status,mn : integer;
  498.  
  499. Begin
  500.   getdate(yy,mm,dd,d);
  501.   str(dd,ds);
  502.   str(yy,ys);
  503.   S1 := Trim(daytab[D])+', ' + trim(ds) + ' ' + Trim(mthtab[mm])+' ' + ys;
  504.   rfc822Date:= s1 + ' ' + systime + ' ' + timezone;
  505. End;
  506.  
  507.  
  508. function getmaildir : string;
  509. {
  510. get station and then scan bindery for this user and
  511. return hexid plus netmaildir as users mail dir
  512. needed to bounce mail
  513. }
  514. var
  515.    uname,uid : string[80];
  516.    stat,retcode : integer;
  517.  
  518. begin
  519.      if standalone then
  520.           getmaildir := homedir
  521.      else
  522.      begin
  523.           uid := '';
  524.           getstation(stat,retcode);
  525.           getuser(stat,uname,retcode);
  526.           gethexid(uname,uid,retcode);
  527.           if (retcode = 0) and (uid > '') then
  528.              getmaildir := firstdrive + netmaildir + '\' + uid
  529.           else
  530.               getmaildir := homedir;
  531.      end; { not standalone }
  532. end; { getmaildir }
  533.  
  534. procedure parse(s : string);
  535. {
  536. extract waffle static file things needed to rewrite the
  537. PMail container file into a form suitable for uucico to export
  538. }
  539. var
  540.    uppers : string;
  541.    found : boolean;
  542.  
  543.  
  544. function find(id,usource,source : string; var dest : string) : boolean;
  545. {
  546. seek id in the source string
  547. if found, return whatever starts with the first alphabetic character
  548. after the id label
  549. }
  550.  
  551. var
  552.    temps : string;
  553.  
  554. function alphaafter(sep,ups,s : string ) : string;
  555. {
  556. return first alpha characters after sep in s
  557. if no sep, returns null string
  558. uses uppercase version of sep and s to find substring
  559. }
  560.  
  561. const alpha : set of char = ['0'..'9','A'..'z','+','-'];
  562.  
  563. var
  564.    i,j,l : integer;
  565.    rets : string;
  566.  
  567. begin
  568.      sep := upcasestr(sep);
  569.      rets := '';
  570.      l := length(s);
  571.      j := length(sep);
  572.      i := pos(sep,ups);
  573.      if (i <> 0) then
  574.      begin
  575.           i := i + j;
  576.           while not (ups[i] in alpha) and (i < l) do
  577.                 inc(i);
  578.           if (i > 0) and  (i <= l)  then
  579.              rets := copy(s,i,l);
  580.      end; { not there }
  581.      alphaafter := rets;
  582. end; { alphaafter }
  583.  
  584.  
  585. begin { find }
  586.       if (pos(id,usource) = 1) then
  587.       begin
  588.            dest := '';
  589.            temps := alphaafter(id,usource,source);
  590.            if (temps = '') then
  591.                 badnews('Blank ' + id + ' specified in ' + wafdir)
  592.            else
  593.            begin
  594.                dest := temps;
  595.                find := true;
  596.            end;
  597.       end { leave dest alone if id not found }
  598.       else
  599.           find := false;
  600. end; { find }
  601.  
  602. begin { parse the waffle static dir line s }
  603.       s := mirt(s);
  604.       uppers := upcasestr(s);
  605.       found := false;
  606.       found := find(hn,uppers,s,hostname);
  607.       if not found then
  608.          found := find(sm,uppers,s,smarthost);
  609.       if not found then
  610.          found := find(tz,uppers,s,timezone);
  611.       if not found then
  612.          found := find(sp,uppers,s,spool);
  613.       if not found then
  614.          found := find(org,uppers,s,organization);
  615.       if not found then
  616.          found := find(ob,uppers,s,outbox);
  617.       if not found then
  618.          found := find(nn,uppers,s,nodename);
  619. end; { parse }
  620.  
  621. procedure getwafflesetup;
  622. {
  623. read static file for essential configuration details
  624. }
  625. begin
  626.    {$i-}
  627.    assign(infile,wafdir);
  628.    reset(infile);
  629.    {$i+}
  630.    dummy := ioresult;
  631.    if (dummy <> 0) then
  632.       badnews(prog + ' ERROR: Unable to open ' + wafdir);
  633.    tmpstring := '';
  634.    timezone := '';
  635.    hostname := '';
  636.    smarthost := '';
  637.    spool := '';
  638.    organization := '';
  639.    outbox := '';
  640.    nodename := '';
  641.    while not eof(infile) do
  642.    begin
  643.       readln(infile,tmpstring);
  644.       if (tmpstring[1] <> '#') and (tmpstring[1] <> ';') then
  645.          parse(tmpstring);
  646.    end; { eof }
  647.    close(infile);
  648.    if (timezone = '') then
  649.       badnews(prog + ' ERROR: No TimeZone in Waffle Static file ' + wafdir);
  650.    if (hostname = '') then
  651.       badnews(prog + ' ERROR: No HostName in Waffle Static file ' + wafdir);
  652.    if (smarthost = '') then
  653.       badnews(prog + ' ERROR: No SmartHost in Waffle Static file ' + wafdir);
  654.    if (spool = '') then
  655.       badnews(prog + ' ERROR: No Spool in Waffle Static file ' + wafdir);
  656.    if (nodename = '') then
  657.       badnews(prog + ' ERROR: No Node name in Waffle Static file ' + wafdir);
  658.    if (outbox <> '') then { just in case an extension supplied }
  659.         outbox := before('.',outbox);
  660.    if (pos('.',smarthost) <> 0) then
  661.       badnews(prog + ' ERROR: Illegal smarthost parameter in Waffle static file');
  662.    if (pos('!',smarthost) <> 0) then
  663.       smarthost := before('!',smarthost);
  664. end; { getwafflesetup }
  665.  
  666. function getnewfilename(dirtocheck : string) : string;
  667. {
  668. make a random filename which does not yet exist there yet
  669. }
  670. var
  671.    fn : string;
  672.  
  673.  
  674. function randstr : string;
  675. {
  676. return a 4 character string of random hex digits
  677. Looks at turbo randseed which is a (4 byte) longint
  678. and converts it to a hex string (8 char) as a file name
  679. }
  680. var
  681.    l : longint;
  682.    h : hexidtype absolute l;
  683.    w : word;
  684.  
  685. begin { randstr }
  686.      w := random(maxint);
  687.      l := randseed; { get longint version }
  688.      randstr := copy(hexidtostring(h),1,4);
  689. end; { randstr }
  690.  
  691. begin { getnewfilename }
  692.      repeat
  693.            fn := randstr;
  694.      until not exists(dirtocheck + fn  + '.DAT');
  695.      getnewfilename := fn;
  696. end; { getnewfilename }
  697.  
  698. procedure writespoolfiles;
  699. {
  700. do all the work of rewriting the spooled mail file and writing the
  701. local and spooled control files
  702. Note problems associated with being on a remote gateway if
  703. remotegateway is true
  704. }
  705. var
  706.    teststring,s : string[80];
  707.    c : char;
  708.    endofheader : boolean;
  709.    ib,ob : array[1..4096] of byte;
  710.    lines : word;
  711.    i : integer;
  712.  
  713. begin { writespoolfiles }
  714.    lines := 0;
  715.    Spool := Spool + '\' + smarthost + '\';
  716.    (* drive and directory from Spool *)
  717.    fsplit(Spool, drive, dir, ext);
  718.    (* file name from input arguments *)
  719.    fsplit(paramstr(containerparam), null, containername, s);
  720.    if remotegateway then
  721.    begin
  722.       if (copy(drive,2,1) = ':') then { must kludge remote drive }
  723.          drive := remotedrive + copy(drive,3,999)
  724.    end;
  725.    wafname := getnewfilename(drive + dir);
  726.    (* put 'em together and what do you get? *)
  727.    dat_filename := drive + dir + wafname + '.DAT';
  728. (*
  729.  *    create the data file for mailing
  730. *)
  731.    {$i-}
  732.    assign(outfile,dat_filename);
  733.    settextbuf(outfile,ob);
  734.    rewrite(outfile);
  735.    {$i+}
  736.    dummy := ioresult;
  737.    if (dummy <> 0) then
  738.       badnews(prog + ' ERROR: Unable to open ' + dat_filename + ' for output');
  739.    containername := upcasestr(mirt(paramstr(containerparam)));
  740.    {$i-}
  741.    assign(infile,containername);
  742.    settextbuf(infile,ib);
  743.    reset(infile);
  744.    {$i+}
  745.    dummy := ioresult;
  746.    if (dummy <> 0) then
  747.       badnews(prog + ' ERROR: Unable to open file ' + containername + ' for input');
  748.    write(outfile,'From ',sender,'  ',datesent,'  remote from ',HostName,newline);
  749.    write(outfile,'Received: from ',uservername,' by ',nodename,newline);
  750.    write(outfile,'          (PMail+UDG ',prog,' ',version,') id ',wafname, ' for ',
  751.    paramstr(toparam),';',newline);
  752.    write(outfile,'          ',rfc822date,newline);
  753.    endofheader := false;
  754.    while not eof(infile) do
  755.    begin
  756.         readln(infile,tmpstring);
  757.         inc(lines);
  758.         if not endofheader and (tmpstring = '') then
  759.         begin
  760.              endofheader := true;
  761.              if (organization > '') then
  762.                 write(outfile,'Organization: ',organization,newline);
  763.         end;
  764.         if not endofheader then
  765.         begin
  766.              teststring := noblanks(upcasestr(tmpstring));
  767.              if (teststring <> replyto) then
  768.              begin { ignore blank reply-to: lines }
  769.                   if (pos(from,teststring) = 1) then
  770.                   begin
  771.                      if (realname > '') then  { add realname to from: line }
  772.                         if (pos('(',tmpstring) = 0) then { not there yet }
  773.                            tmpstring := tmpstring + ' (' + realname + ')';
  774.                   end;
  775.                   if (pos(confirm,teststring) <> 0) then
  776.                           confirmation := true;
  777.                   if (pos(toline,teststring) = 1) then
  778.                   begin
  779.                        i := pos(ccmailstuff,tmpstring);
  780.                        if (i <> 0) then { zap ccmail crap }
  781.                        begin
  782.                           tmpstring := copy(tmpstring,1,pred(i));
  783.                           ccmailzap := true;
  784.                        end;
  785.                   end;
  786.                   write(outfile,tmpstring,newline);
  787.              end
  788.              else
  789.              begin { zap blank reply to }
  790.                   writeln(prog,' WARNING - Blank reply-to zapped');
  791.                   delay(1000);
  792.              end;
  793.         end
  794.         else
  795.             write(outfile,tmpstring,newline);
  796.         if (lines mod 100) = 0 then
  797.            write('.');
  798.    end;
  799.    close(infile);
  800.    close(outfile);
  801.    { now shorten hostname for xqt etc }
  802.    shorthostname := mirt(copy(hostname,1,7));
  803.  
  804. (*
  805.  * create the '.CMD' file - commands to UUCICO (?)
  806.  *    Format:
  807.  *    S 0051.DAT D.home0051 brendan - 0051.DAT 0666
  808.  *    S 0051.XQT X.home0051 brendan - 0051.XQT 0666
  809.  *
  810.  *  (roughly)
  811.  *    SEND local-filename as-filename from - ????? unix-file-mode
  812. *)
  813.    fsplit(dat_FileName, dir, wafname, ext);
  814.    cmd_FileName := dir + wafname + '.CMD';
  815.    {$i-}
  816.    assign(outfile,cmd_filename);
  817.    rewrite(outfile);
  818.    {$i+}
  819.    dummy := ioresult;
  820.    if (dummy <> 0) then
  821.       badnews(prog + ' ERROR: Unable to open CMD file ' + cmd_filename + ' for output');
  822.    dat_filename := wafname + datext;
  823.    xqt_filename := wafname + xqtext;
  824.    writeln(outfile,'S ',dat_filename,' D.',shorthostname,wafname,' ',sender,
  825.    ' - ',dat_filename,' 0666');
  826.    writeln(outfile,'S ',xqt_filename,' X.',shorthostname,wafname,' ',sender,
  827.    ' - ',xqt_filename,' 0666');
  828.    close(outfile);
  829.  
  830.  (*
  831.   *    Create the '.XQT' file --  commands to uuxqt at the other end!
  832.   *
  833.   *
  834.   *    Format:
  835.   *    U brendan home
  836.   *    Z
  837.   *    F  D.home0051
  838.   *    I D.home0051
  839.   *    C rmail brendan
  840.   *
  841.   *    where the commands defined in the uuxqt file are (as stated by
  842.   *     Ian Taylor (Ian@airs.com, uunet!airs!ian) in a newsitem posted
  843.   *    to comp.unix.internals 4 Apr 1992)
  844.   *
  845.   *    'Here are the commands defined in uuxqt files:
  846.   *
  847.   *     C command-line
  848.   *     I standard-input
  849.   *     O standard-output [ system ]
  850.   *     F required-file filename-to-use
  851.   *     R requestor-address
  852.   *     U user system
  853.   *     Z (acknowledge if command failed; default)
  854.   *     N (no acknowledgement on failure)
  855.   *     n (acknowledge if command succeeded)
  856.   *     B (return command input on error)
  857.   *     e (process with sh)
  858.   *     E (process with exec)
  859.   *     M status-file
  860.   *     # comment                    '
  861.   *
  862.   *)
  863.   xqt_filename := dir + wafname + xqtext;
  864.   {$i-}
  865.    assign(outfile,xqt_filename);
  866.    rewrite(outfile);
  867.    {$i+}
  868.    dummy := ioresult;
  869.    if (dummy <> 0) then
  870.       badnews(prog + ' ERROR: Unable to open XQT file ' + xqt_filename + ' for output');
  871.    tmpstring := paramstr(toparam);
  872.    i := pos(ccmailstuff,tmpstring);
  873.    if (i <> 0) then { zap ccmail crap }
  874.    begin
  875.         tmpstring := copy(tmpstring,1,pred(i));
  876.         ccmailzap := true;
  877.    end;
  878.    write(outfile,'U ',sender,' ',hostname,newline);
  879.    write(outfile,'R ',sender,' ',hostname,newline);
  880.    write(outfile,'Z',newline);
  881.    write(outfile,'F D.',shorthostname,wafname,newline);
  882.    write(outfile,'I D.',shorthostname,wafname,newline);
  883.    write(outfile,'C rmail ',tmpstring,newline);
  884.    close(outfile);
  885. end;
  886.  
  887.  
  888. function findandmap(s : string) : string;
  889. {
  890. return waffle static file path if can successfully parse parameter 8
  891. into a servername, volume, path to static file and if we can attach
  892. and map to it using the current wafpeg userid/password defined as
  893. constants above
  894. If no luck, bounce outgoing mail to sender
  895. }
  896. var
  897.    umaildir,staticstring,tmpstring,remotevol,
  898.    remoteserver,remotepath,rdir,rname,rext,newpath : string[80];
  899.    dummy : integer;
  900.  
  901.  
  902. procedure bounceit;
  903. {
  904. send it back
  905. }
  906. var
  907.    newfilename : string;
  908.  
  909. function getnewfilename : string;
  910. {
  911. make a random filename which does not yet exist here
  912. }
  913. var
  914.    fn : string;
  915.  
  916. function randstr : string;
  917. {
  918. return a 4 character string of random hex digits
  919. Looks at turbo randseed which is a (4 byte) longint
  920. and converts it to a hex string (4 char) as a file name
  921. }
  922. var
  923.    l : longint;
  924.    w : word;
  925.    h : hexidtype absolute l;
  926.  
  927. begin { randstr }
  928.      w := random(maxint);
  929.      l := randseed; { get longint version }
  930.      randstr := copy(hexidtostring(h),1,4);
  931. end; { randstr }
  932.  
  933. begin { getnewfilename }
  934.      randomize;
  935.      repeat
  936.            fn := randstr + PMailext;
  937.      until not exists(umaildir + '\' + fn);
  938.      getnewfilename := umaildir + '\' + fn;
  939. end; { getnewfilename }
  940.  
  941.  
  942. begin { bounceit }
  943.       umaildir := getmaildir;
  944.       newfilename := getnewfilename;
  945.       window(5,10,75,25,fc,bc,drev,shad);
  946.       windowtitle(prog + ' Fatal error');
  947.       writeln('Your PMail UDG configuration may be wrong or the');
  948.       writeln('remote server might be down or otherwise not cooperative');
  949.       writeln('Your outgoing mail will now be returned to you and will appear');
  950.       writeln('as new mail so you can try to send it later when the problem is fixed');
  951.       if (umaildir = homedir) then
  952.          writeln('It will appear as file ',newfilename);
  953.       wait;
  954.       closewindow;
  955.       {$i-}
  956.       assign(outfile,newfilename);
  957.       rewrite(outfile);
  958.       {$i+}
  959.       dummy := ioresult;
  960.       if (dummy <> 0) then
  961.       begin
  962.            window(5,10,75,25,fc,bc,drev,shad);
  963.            windowtitle(prog + ' Fatal error');
  964.            writeln('Unable to open ',newfilename,' for output');
  965.            writeln('Your mail is left as ',paramstr(containerparam),', write this down so you can');
  966.            writeln('retrieve it for resending');
  967.            wait;
  968.            closewindow;
  969.            if remotegateway then
  970.            begin
  971.                 logout_from_file_server(remoteserverid);
  972.                 detach_from_file_server(remoteserverid,dummy);
  973.            end;
  974.            halt(1);
  975.       end;
  976.       {$i-}
  977.       assign(infile,paramstr(containerparam));
  978.       reset(infile);
  979.       {$i+}
  980.       dummy := ioresult;
  981.       if (dummy <> 0) then
  982.       begin
  983.            window(5,10,75,25,fc,bc,drev,shad);
  984.            windowtitle(prog + ' Fatal error');
  985.            writeln('Unable to open PMail container file ',
  986.              paramstr(containerparam),' for input');
  987.            wait;
  988.            closewindow;
  989.            close(outfile);
  990.            if remotegateway then
  991.            begin
  992.                 logout_from_file_server(remoteserverid);
  993.                 detach_from_file_server(remoteserverid,dummy);
  994.            end;
  995.            halt(1);
  996.       end;
  997.       while not eof(infile) do
  998.       begin
  999.            readln(infile,tmpstring);
  1000.            writeln(outfile,tmpstring);
  1001.       end;
  1002.       close(infile);
  1003.       close(outfile);
  1004.       window(5,10,75,15,fc,bc,drev,shad);
  1005.       windowtitle(prog + ' Function Completed');
  1006.       writec('Mail bounced',2);
  1007.       wait;
  1008.       closewindow;
  1009. end; { bounceit }
  1010.  
  1011. {$ifdef single}
  1012. begin { findandmap }
  1013.       window(5,10,75,25,fc,bc,drev,shad);
  1014.       windowtitle(prog + ' Fatal error');
  1015.       writeln('Sorry, this version cannot deal with remote novell servers');
  1016.       writeln('Contact rossl@gmu.wh.su.edu.au for details of the version you need');
  1017.       wait;
  1018.       closewindow;
  1019.       close(outfile);
  1020.       halt(1);
  1021. end;
  1022. {$else}
  1023. begin { findandmap }
  1024.      staticstring := '';
  1025.      if pos(s,'/') <> 0 then
  1026.      begin { path has been supplied eg gmu/sys:waffle\system.static - parse }
  1027.         remoteserver := upcasestr(before('/',s));
  1028.         remotepath := after('/',s);
  1029.      end
  1030.      else
  1031.      begin { use default path for waffle static file }
  1032.           remoteserver := upcasestr(s);
  1033.           remotepath := '\waffle\system\static';
  1034.      end;
  1035.      if (pos(':',remotepath) > 0) then { parse vol name eg sys:}
  1036.      begin
  1037.           remotevol := before(':',remotepath) + ':';
  1038.           remotepath := after(':',remotepath);
  1039.      end
  1040.      else
  1041.          remotevol := 'SYS:';
  1042.      fsplit(remotepath,rdir,rname,rext);
  1043.      if (copy(rdir,length(rdir),1) = '\') then
  1044.         rdir := copy(rdir,1,pred(length(rdir)));
  1045.      if (copy(rdir,1,1) <> '\') then
  1046.         rdir := '\' + rdir;
  1047.      newpath := remotedrive + rdir;
  1048.      remoteserverid := login(remoteserver,userobject,hostlogin,hostpass);
  1049.      if (remoteserverid > 0) then
  1050.      begin   { m:=sys:waffle\system\static,etc }
  1051.         remotegateway := true;
  1052.         if mapremotedrive(remotedrive + '=' + remotevol,newpath,remoteserverid,remotehandle) then
  1053.         begin
  1054.              {$i-}
  1055.              chdir(newpath); { m:\waffle\system eg }
  1056.              {$i+}
  1057.              dummy := ioresult;
  1058.              if (dummy = 0) then
  1059.                 staticstring := newpath + '\' + rname + rext
  1060.              else
  1061.              begin
  1062.                   window(5,10,75,15,fc,bc,drev,shad);
  1063.                   windowtitle(prog + ' Fatal Configuration error');
  1064.                   writeln('Unable to change to ',newpath);
  1065.                   writeln('Please let your network supervisor know that the gateway is broken');
  1066.                   wait;
  1067.                   closewindow;
  1068.              end;
  1069.         end
  1070.         else
  1071.         begin
  1072.              window(5,10,75,15,fc,bc,drev,shad);
  1073.              windowtitle(prog + ' Fatal Configuration error');
  1074.              writeln('Able to login, but unable to map to ',remotepath);
  1075.              writeln('Server ',remoteserver,' or your PMail UDG might be broken');
  1076.              writeln('See your network supervisor for help');
  1077.              wait;
  1078.              closewindow;
  1079.         end;
  1080.      end
  1081.      else
  1082.      begin
  1083.           window(5,10,75,15,fc,bc,drev,shad);
  1084.           windowtitle(prog + ' Fatal Configuration error');
  1085.           writeln('Unable to log in to ',remoteserver,' as ',hostlogin,'.');
  1086.           writeln('That server might be down or the userid and/or your ');
  1087.           writeln('PMail UDG might be broken - ask your network supervisor');
  1088.           wait;
  1089.           closewindow;
  1090.      end;
  1091.      if (staticstring = '') then
  1092.      begin { failed - return to default server and bounce }
  1093.            set_preferred_connection_id(defaultserverid);
  1094.            bounceit;
  1095.            if remotegateway then
  1096.            begin
  1097.                 logout_from_file_server(remoteserverid);
  1098.                 detach_from_file_server(remoteserverid,dummy);
  1099.            end;
  1100.            halt(1);
  1101.      end;
  1102.      findandmap := staticstring;
  1103. end;
  1104. {$endif}
  1105.  
  1106. procedure deleteold;
  1107. begin { delete old mail if got this far }
  1108.       {$i-}
  1109.       assign(f,paramstr(containerparam));
  1110.       erase(f);
  1111.       dummy := ioresult;
  1112.       if (dummy <> 0) then
  1113.       begin
  1114.            window(5,10,75,15,fc,bc,drev,shad);
  1115.            windowtitle(prog + ' Probable Configuration error');
  1116.            writeln(progname,' ERROR: unable to erase old PMail temporary file ',
  1117.               paramstr(containerparam));
  1118.            wait;
  1119.            closewindow;
  1120.            if remotegateway then
  1121.            begin
  1122.                 logout_from_file_server(remoteserverid);
  1123.                 detach_from_file_server(remoteserverid,dummy);
  1124.            end;
  1125.            halt(1);
  1126.       end;
  1127.       {$i+}
  1128. end; { delete old file on completion }
  1129.  
  1130. (*
  1131. procedure saygone;
  1132. {
  1133. tell user message appears to have gone
  1134. }
  1135. begin
  1136.      if realname = '' then
  1137.         realname := sender;
  1138.      with t do
  1139.           gettime(h,m,s,s100);
  1140.      started := msec(t);
  1141.      window(2,9,78,21,fc,bc,dnorm,shad);
  1142.      windowtitle(prog + ' ' + ver);
  1143.      writec('PMail has called ' + progname ,1);
  1144.      writec(copyright,2);
  1145.      writec(copyright2,3);
  1146.      if standalone then
  1147.         writec('(STANDALONE MODE  - no Netware detected !)',4);
  1148.      writec('Your mail has been queued for delivery, and',5);
  1149.      writec('will soon be on its way out of here',6);
  1150.      writec('First detected netware drive = ' + firstdrive,7);
  1151.      if ccmailzap then
  1152.         writec('cc:mail stupidity has been repaired !',8);
  1153.      case (random(29)) of
  1154.         1:writec('All care, no responsibility',9);
  1155.         2:writec('There is no (apparent) immediate cause for alarm',9);
  1156.         3:writec('Your mileage may vary; Void where prohibited; Unsuitable for minors',9);
  1157.         4:writec('Don''t Panic!',9);
  1158.         5:writec('The more things change, the more they stay different',9);
  1159.         6:writec('Please DO NOT adjust your computer',9);
  1160.         7:writec('If anything possibly can go wrong, it will.',9);
  1161.         8:writec('Things always go wrong at the worst possible time.',9);
  1162.         9:writec('And now back to your normal programme',9);
  1163.         10:writec('RELAX !!! It''s only ones and zeros',9);
  1164.         11:writec('Death is Nature''s way of telling you to slow down',9);
  1165.         12:writec('This sentence is untrue. (Think about it)',9);
  1166.         13:writec(realname + ' CANNOT believe this sentence without being inconsistent',9);
  1167.         14:writec('Shit Happens',9);
  1168.         15:writec('Don''t press <Cntl><Alt><Del> to continue',9);
  1169.         16:writec('Cats crawl under Gates, Everything crawls under Windows',9);
  1170.         17:writec('Incest (n): sibling revelry',9);
  1171.         18:writec('SYSTEM ERROR: Hit Any User to Continue',9);
  1172.         19:writec('Cocaine is nature''s way of telling you that you have too much money',9);
  1173.         20:writec('WINDOWS ERRORS #39: Cannot open Window. Please use the door',9);
  1174.         21:writec('APATHY ERROR: Don''t bother hitting any keys at all',9);
  1175.         22:writec('FAMOUS WINDOWS ERRORS #23: It''s really not your fault. Really',9);
  1176.         23:writec('WINDOWS ERROR #1: All windows errors are due to Installing windows..',9);
  1177.         24:writec('WINDOWS ERROR #9: No one will ever see this error. Ever. No one.',9);
  1178.         25:writec('Never argue with a fool. Onlookers might not know the difference',9);
  1179.         26:writec('I thought YOU did the backup ?!?!?',9);
  1180.         27:writec('The attention span of a computer is about as long as the power cord.',9);
  1181.         28:writec('Recursion (n): See "Recursion"',9);
  1182.      end;
  1183.      writec('Press a key to continue or wait for a few seconds...',10);
  1184.         if (pos('ß',ver) <> 0) then
  1185.            writec('This is a BETA TEST VERSION - PLEASE DO NOT DISTRIBUTE',12);
  1186.      repeat
  1187.            with t do
  1188.                 gettime(h,m,s,s100);
  1189.            now := msec(t);
  1190.      until keypressed or (now > (started + 500));
  1191.      if keypressed then
  1192.            ch := readkey;
  1193.      closewindow;
  1194. end; { advertise }
  1195. *)
  1196.  
  1197.  
  1198.  
  1199. procedure makecopy;
  1200.  
  1201. var
  1202.    s,st : string;
  1203.    ix,lastix : windex;
  1204.    ofile,ifile : file of windex;
  1205.    newstart,clength : longint;
  1206.    name,dir,ext : string;
  1207.  
  1208. begin { we have an outbox - copy this outgoing mail there }
  1209.        if remotegateway then
  1210.        begin { ensure outbox is on remote server }
  1211.             if (pos(':',outbox) <> 0) then
  1212.                outbox := after(':',outbox);
  1213.             outbox := remotedrive + outbox;
  1214.        end;
  1215.        {$i-}
  1216.        s := outbox + '.' + outboxext;
  1217.        if not exists(s) then
  1218.        begin
  1219.             assign(infile,s);
  1220.             rewrite(infile);
  1221.             dummy := ioresult;
  1222.             if (dummy <> 0) then
  1223.             begin
  1224.                  window(5,10,75,15,fc,bc,drev,shad);
  1225.                  windowtitle(prog + ' Configuration Problem');
  1226.                  writec('Sorry - cannot create a new outbox - ' + s,3);
  1227.                  wait;
  1228.                  closewindow;
  1229.                  exit;
  1230.             end;
  1231.             close(infile);
  1232.             s := outbox + '.' + outboxindexext;
  1233.             assign(ifile,s);
  1234.             rewrite(ifile);
  1235.             dummy := ioresult;
  1236.             if (dummy <> 0) then
  1237.             begin
  1238.                  window(5,10,75,15,fc,bc,drev,shad);
  1239.                  windowtitle(prog + ' Configuration Problem');
  1240.                  writec('Sorry - cannot create a new outbox index - ' + s,3);
  1241.                  wait;
  1242.                  closewindow;
  1243.                  exit;
  1244.             end;
  1245.             close(ifile);
  1246.        end; { new outbox }
  1247.        s := outbox + '.' + outboxext;
  1248.        assign(outfile,s);
  1249.        append(outfile);
  1250.        write(outfile,mailsep);
  1251.        dummy := ioresult;
  1252.        if (dummy <> 0) then
  1253.        begin
  1254.             window(5,10,75,15,fc,bc,drev,shad);
  1255.             windowtitle(prog + ' Mail Archiving Problem');
  1256.             writec('Cannot write mail item separator to outbox ' + s,3);
  1257.             wait;
  1258.             closewindow;
  1259.             exit;
  1260.        end;
  1261.        assign(infile,paramstr(containerparam));
  1262.        reset(infile);
  1263.        dummy := ioresult;
  1264.        if (dummy <> 0) then
  1265.        begin
  1266.             s := paramstr(containerparam);
  1267.             window(5,10,75,15,fc,bc,drev,shad);
  1268.             windowtitle(prog + ' Mail Archiving Problem');
  1269.             writec('Cannot open ' + s + ' to copy to outbox',3);
  1270.             wait;
  1271.             closewindow;
  1272.             exit;
  1273.        end;
  1274.        clength := 0;
  1275.        while not eof(infile) do
  1276.        begin
  1277.             readln(infile,s);
  1278.             inc(clength,length(s)); { count length }
  1279.             inc(clength,2); { add crlf }
  1280.             writeln(outfile,s);
  1281.             dummy := ioresult;
  1282.             if (dummy <> 0) then
  1283.             begin
  1284.                  window(5,10,75,15,fc,bc,drev,shad);
  1285.                  windowtitle(prog + ' Mail Archiving Problem');
  1286.                  writec('Write error on outbox copy ' + s + ' is the disk full ??',3);
  1287.                  wait;
  1288.                  closewindow;
  1289.                  exit;
  1290.             end;
  1291.        end;
  1292.        close(infile);
  1293.        close(outfile);
  1294.        s := outbox + '.' + outboxindexext;
  1295.        st := outbox + '.' + '~~~';
  1296.        assign(ofile,st);
  1297.        rewrite(ofile);
  1298.        dummy := ioresult;
  1299.        if (dummy <> 0) then
  1300.        begin
  1301.             window(5,10,75,15,fc,bc,drev,shad);
  1302.             windowtitle(prog + ' Mail Archiving Problem');
  1303.             writeln('Cannot rewrite ',st, '. Is it write protected ??');
  1304.             wait;
  1305.             closewindow;
  1306.             exit;
  1307.        end;
  1308.        assign(ifile,s);
  1309.        reset(ifile);
  1310.        while not eof(ifile) do
  1311.        begin { make a new copy and keep the last index pointer }
  1312.              read(ifile,lastix);
  1313.              write(ofile,lastix);
  1314.              dummy := ioresult;
  1315.              if (dummy <> 0) then
  1316.              begin
  1317.                   window(5,10,75,15,fc,bc,drev,shad);
  1318.                   windowtitle(prog + ' Mail Archiving Problem');
  1319.                   writec('Write error on ' + st +  '. Is the disk full ??',3);
  1320.                   wait;
  1321.                   closewindow;
  1322.                   exit;
  1323.              end;
  1324.        end; { eof (ifile) }
  1325.        close(ifile);
  1326.        erase(ifile);
  1327.        dummy := ioresult;
  1328.        if (dummy <> 0) then
  1329.        begin
  1330.             window(5,10,75,15,fc,bc,drev,shad);
  1331.             windowtitle(prog + ' Mail Archiving Problem');
  1332.             writec('Cannot erase ' + s +  '. Is it write protected ??',3);
  1333.             wait;
  1334.             closewindow;
  1335.             exit;
  1336.        end;
  1337.        fillchar(lastix.stuff,sizeof(lastix.stuff),0); { clear it }
  1338.        inc(lastix.offset,lastix.length + 4); { new start - sep and prev length }
  1339.        lastix.length := clength; { length of this message }
  1340.        write(ofile,lastix); { update the index file }
  1341.        close(ofile);
  1342.        fsplit(s,dir,name,ext);
  1343.        chdir(dir);
  1344.        dummy := ioresult;
  1345.        if (dummy <> 0) then
  1346.        begin
  1347.             window(5,10,75,15,fc,bc,drev,shad);
  1348.             windowtitle(prog + ' Mail Archiving Problem');
  1349.             writec('Cannot change directory to ' + dir,3);
  1350.             wait;
  1351.             closewindow;
  1352.             exit;
  1353.        end;
  1354.        s := name + '.' + outboxindexext;
  1355.        st := name + '.~~~';
  1356.        assign(f,st);
  1357.        rename(f,s);
  1358.        dummy := ioresult;
  1359.        if (dummy <> 0) then
  1360.        begin
  1361.             window(5,10,75,15,fc,bc,drev,shad);
  1362.             windowtitle(prog + ' Mail Archiving Problem');
  1363.             writeln('Cannot rename outbox index file ',st,' to ',s);
  1364.             writeln('Ask the Supervisor for ALL rights to the outbox directory');
  1365.             writeln('Tell her to read the documentation !');
  1366.             wait;
  1367.             closewindow;
  1368.             exit;
  1369.        end;
  1370.        { out file renamed to old name ie outbox.i }
  1371.        {$i+}
  1372. end;
  1373.  
  1374.  
  1375. begin { main }
  1376.    randomize; { init new file name generator }
  1377.    if not apiavailable then
  1378.    begin
  1379.         standalone := true;
  1380.         realname := '';
  1381.         station := 0;
  1382.         sender := getenv(pmenvar);
  1383.         if sender > '' then
  1384.            sender := lowercasestr(sender)
  1385.         else
  1386.         begin
  1387.              writeln('DOS environment variable ',pmenvar,' is NOT available');
  1388.              writeln('Please alter your AUTOEXEC.BAT to define one. See documentation');
  1389.              writeln('Terminating abnormally - mail NOT SENT !');
  1390.              delay(2000);
  1391.              halt(1);
  1392.         end;
  1393.  
  1394.    end
  1395.    else
  1396.    begin
  1397.           getdir(0,homedir);
  1398.           get_default_connection_id(defaultserverid);
  1399.           getstation(station,dummy);
  1400.           getuser(station,sender,dummy);
  1401.           get_realname(sender,realname,dummy);
  1402.           if (dummy <> 0) then
  1403.              realname := ''
  1404.           else
  1405.               realname := trim(realname);
  1406.           getservername(uservername,dummy);
  1407.           sender := lowercasestr(sender);
  1408.           firstdrive := first_networked_drive + ':';
  1409.    end; { netware }
  1410.    remotegateway := false;
  1411.    if (paramcount < 2) then
  1412.    begin
  1413.       window(5,10,75,24,fc,bc,drev,shad);
  1414.       windowtitle(prog + ' Configuration/Installation Problem');
  1415.       writec(progname,1);
  1416.       writec(ver,2);
  1417.       writec('Usage: ' + prog + ' container_file to_line [remote details]',4);
  1418.       str(paramcount,tmpstring);
  1419.       writec('First detected netware drive = ' + firstdrive,5);
  1420.       writec('Called with ' + tmpstring + ' parameters',6);
  1421.       writeln;
  1422.       for i := 1 to paramcount do
  1423.       begin
  1424.            str(i,tmpstring);
  1425.            writeln('Parameter' + tmpstring + ' = ',paramstr(i));
  1426.       end;
  1427.       wait;
  1428.       closewindow;
  1429.       halt(1);
  1430.    end;
  1431.    if (paramcount > 2) and not standalone then
  1432.    begin { must be a remote server - seek and attach to it }
  1433.          if paramcount > 3 then
  1434.             hostlogin := paramstr(ruserparam);
  1435.          if paramcount > 4 then
  1436.             hostpass := paramstr(rpassparam);
  1437.          wafdir := findandmap(paramstr(rservparam));
  1438.    end
  1439.    else
  1440.    begin { find waffle static file from dos set variable }
  1441.         wafdir := getenv(waffleset);
  1442.         if (wafdir = '') then
  1443.              wafdir := firstdrive + defaultwafdir;
  1444.    end;
  1445.    getwafflesetup;
  1446.    datesent := rfc822date;
  1447.    if standalone then
  1448.       uservername := sender + '@' + hostname
  1449.    else
  1450.        uservername := uservername + '/' + sender;
  1451.    uservername := lowercasestr(uservername);
  1452.    writespoolfiles;
  1453.    if (outbox > '') then
  1454.       makecopy;
  1455.    if remotegateway and not standalone then
  1456.    begin
  1457.         logout_from_file_server(remoteserverid);
  1458.         detach_from_file_server(remoteserverid,dummy);
  1459.         {$i-}
  1460.         chdir(homedir);
  1461.         {$i+}
  1462.         dummy := ioresult;
  1463.         if (dummy <> 0) then
  1464.            writeln(progname,' ERROR - Unable to change back to ',homedir);
  1465.    end;
  1466.    if killsent then
  1467.       deleteold
  1468.    else
  1469.    begin
  1470.        writeln('Old container file NOT KILLED as run in debug mode');
  1471.        delay(1000);
  1472.    end;
  1473.    (*
  1474.    if not confirmation then
  1475.             saygone;
  1476.    *)
  1477. end.
  1478. { pegwaf.pas }
  1479.